home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Library-2.01 / quickdraw.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  19.8 KB  |  588 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;  Quickdraw.lisp
  4. ;;
  5. ;;  version 2.0
  6. ;;
  7. ;;  copyright 1987-89 Apple Computer, Inc
  8. ;;
  9. ;;  This file implements a full error-checked interface to Quickdraw.
  10. ;;  It is meant to be useful both in programs and as an example of how to use
  11. ;;  the low-level interface to the Mac.
  12. ;;
  13. ;;  You can compile selected portions of this file, but if you do, make sure to
  14. ;;  include the macros and utility functions from the top.
  15. ;;
  16. ;;  Because these functions perform a view-focus on every drawing command,
  17. ;;  they can be slow.  For faster drawing you should only focus the view
  18. ;;  once, and then issue a series of drawing commands.  You can use
  19. ;;  this file as an example of how to call the Quickdraw traps directly
  20. ;;  in such a situation.
  21. ;;
  22.  
  23. ;;;;;;;
  24. ;;
  25. ;; Mod history
  26. ;;
  27. ;; 04/28/93 mwp Release
  28. ;; 05/19/92 bill get-polygon had an object-lisp'ism for clearing the 'my-poly slot
  29. ;; ------------- 2.0
  30. ;; 10/16/91 bill PSZ's simplification of with-rectangle-arg
  31. ;; ------------- 2.0b3
  32. ;; 08/26/91 bill downward-function -> dynamic-extent
  33. ;; 08/17/91 bill (pset x :record.slot v) -> (setf (pref x :record.slot) v)
  34. ;;               No more (require-interface :quickdraw), autoloading is faster.
  35. ;; 07/09/91 bill rref & rset -> pref/href & pset/hset
  36. ;; ------------- 2.0b2
  37. ;; 02/20/91 bill with-pointers in copy-bits, *32-bit-qd-pen-modes* in mode-arg
  38. ;;--------------- 2.0b1
  39. ;;
  40.  
  41. (in-package :ccl)
  42.  
  43. (eval-when (:compile-toplevel :load-toplevel :execute)
  44.   (export '(clip-region set-clip-region clip-rect pen-show pen-hide
  45.             pen-shown-p pen-position pen-size set-pen-size pen-mode
  46.             set-pen-mode pen-pattern set-pen-pattern pen-state
  47.             set-pen-state pen-normal move-to move line-to line
  48.             offset-rect inset-rect intersect-rect union-rect point-in-rect-p
  49.             points-to-rect point-to-angle equal-rect empty-rect-p frame-rect
  50.             paint-rect erase-rect invert-rect fill-rect frame-oval paint-oval
  51.             erase-oval invert-oval fill-oval frame-round-rect paint-round-rect
  52.             erase-round-rect invert-round-rect fill-round-rect frame-arc
  53.             paint-arc erase-arc invert-arc fill-arc new-region dispose-region
  54.             copy-region set-empty-region set-rect-region open-region close-region
  55.             offset-region inset-region intersect-region union-region
  56.             difference-region xor-region point-in-region-p rect-in-region-p
  57.             equal-region-p empty-region-p frame-region paint-region erase-region
  58.             invert-region fill-region start-picture get-picture draw-picture
  59.             kill-picture start-polygon get-polygon kill-polygon offset-polygon
  60.             frame-polygon paint-polygon erase-polygon invert-polygon fill-polygon
  61.             local-to-global global-to-local get-pixel scale-point map-point
  62.             map-rect map-region map-polygon make-bitmap copy-bits scroll-rect
  63.             origin set-origin)
  64.           :ccl))
  65.  
  66.  
  67. (defmacro with-rectangle-arg ((var left &optional top right bottom) &body body)
  68.   "takes a rectangle, two points, or four coordinates and makes a rectangle.
  69. body is evaluated with VAR bound to that rectangle."
  70.   `(rlet ((,var :rect))
  71.      (setup-rect ,var ,left ,top ,right ,bottom)
  72.      ,@body))
  73.  
  74. (defun setup-rect (rect left top right bottom)
  75.   (cond (bottom
  76.          (setf (pref rect rect.topleft) (make-point left top))
  77.          (setf (pref rect rect.bottomright) (make-point right bottom)))
  78.         (right
  79.          (error "Illegal rectangle arguments: ~s ~s ~s ~s"
  80.                 left top right bottom))
  81.         (top
  82.          (setf (pref rect rect.topleft) (make-point left nil))
  83.          (setf (pref rect rect.bottomright) (make-point top nil)))
  84.         (t (%setf-macptr rect left))))
  85.  
  86. (defvar *32-bit-qd-pen-modes*
  87.   '((:blend . 32)
  88.     (:addPin . 33)
  89.     (:addOver . 34)
  90.     (:subPin . 35)
  91.     (:transparent . 36)
  92.     (:adMax . 37)
  93.     (:subOver . 38)
  94.     (:adMin . 39)
  95.     (:hilite . 50)))
  96.  
  97. (defun mode-arg (thing)
  98.   (or
  99.    (and (fixnump thing) (<= 0 thing 64) thing)
  100.    (position thing *pen-modes*)
  101.    (cdr (assq thing *32-bit-qd-pen-modes*))
  102.    (error "Unknown pen mode: ~a" thing)))
  103.  
  104. (defmethod origin ((view simple-view))
  105.   (view-scroll-position view))
  106.  
  107. (defmethod set-origin ((view simple-view) h &optional v)
  108.   (set-view-scroll-position view h v nil))
  109.  
  110.  
  111. (defmethod clip-region ((view simple-view) &optional (save-region (#_NewRgn)))
  112.   (with-focused-view view
  113.     (#_GetClip save-region))
  114.   save-region)
  115.  
  116. (defmethod set-clip-region ((view simple-view) new-region)
  117.   (with-focused-view view
  118.     (#_SetClip new-region))
  119.   new-region)
  120.  
  121. (defmethod clip-rect ((view simple-view) left &optional top right bot)
  122.   (with-rectangle-arg (r left top right bot)
  123.     (with-focused-view view
  124.       (#_ClipRect r)))
  125.   nil)
  126.  
  127. (defmethod pen-show ((view simple-view))
  128.   (setf (pref (wptr view) grafport.pnvis) 0)
  129.   nil)
  130.  
  131. (defmethod pen-hide ((view simple-view))
  132.   (setf (pref (wptr view) grafport.pnvis) -1)
  133.   nil)
  134.  
  135. (defmethod pen-shown-p ((view simple-view))
  136.   (> (pref (wptr view) grafport.pnvis) -1))
  137.  
  138. (defmethod pen-position ((view simple-view))
  139.  (with-focused-view view
  140.    (pref (wptr view) windowRecord.pnloc)))
  141.  
  142. (defmethod pen-size ((view simple-view))
  143.   (pref (wptr view) windowRecord.pnsize))
  144.  
  145. (defmethod set-pen-size ((view simple-view) h &optional v &aux (pt (make-point h v)))
  146.   (with-port (wptr view) (#_PenSize :long pt))
  147.   pt)
  148.  
  149. (defmethod pen-mode ((view simple-view))
  150.   (elt *pen-modes* (pref (wptr view) windowRecord.pnmode)))
  151.  
  152. (defmethod set-pen-mode ((view simple-view) new-mode)
  153.   (with-port (wptr view) (#_PenMode (mode-arg new-mode))))
  154.  
  155. (defmethod pen-pattern ((view simple-view) &optional
  156.                         (save-pat (make-record (:pattern :storage :pointer))))
  157.   (copy-record
  158.    (pref (wptr view) windowRecord.pnPat) (:pattern :storage :pointer) save-pat))
  159.  
  160. (defmethod set-pen-pattern ((view simple-view) new-pattern)
  161.   (with-port (wptr view)
  162.     (#_PenPat new-pattern))
  163.   new-pattern)
  164.  
  165. (defmethod pen-state ((view simple-view) &optional (save-state (make-record :penstate)))
  166.  (with-focused-view view
  167.    (#_GetPenState save-state))
  168.  save-state)
  169.  
  170. (defmethod set-pen-state ((view simple-view) new-state)
  171.   (with-focused-view view
  172.     (#_SetPenState new-state))
  173.   new-state)
  174.  
  175. (defmethod pen-normal ((view simple-view))
  176.   (with-focused-view view (#_PenNormal)))
  177.  
  178. (defmethod move-to ((view simple-view) h &optional v)
  179.   (with-focused-view view (#_MoveTo :long (setq h (make-point h v))))
  180.   h)
  181.  
  182. (defmethod move ((view simple-view) h &optional v)
  183.   (with-focused-view view (#_Move :long (setq h (make-point h v))))
  184.   h)
  185.  
  186. (defmethod line-to ((view simple-view) h &optional v)
  187.   (with-focused-view view (#_LineTo :long (setq h (make-point h v))))
  188.   h)
  189.  
  190. (defmethod line ((view simple-view) h &optional v)
  191.   (with-focused-view view (#_Line :long (setq h (make-point h v))))
  192.   h)
  193.  
  194. (defun offset-rect (rect h &optional v)
  195.   (#_OffsetRect :ptr rect :long (make-point h v))
  196.   rect)
  197.  
  198. (defun inset-rect (rect h &optional v)
  199.   (#_InsetRect :ptr rect :long (make-point h v))
  200.   rect)
  201.  
  202. (defun intersect-rect (rect1 rect2 dest-rect)
  203.   (#_SectRect rect1 rect2 dest-rect)
  204.   dest-rect)
  205.  
  206. (defun union-rect (rect1 rect2 dest-rect)
  207.   (#_UnionRect rect1 rect2 dest-rect)
  208.   dest-rect)
  209.  
  210. (defun point-in-rect-p (rect h &optional v)
  211.   (#_PtInRect (make-point h v) rect))
  212.  
  213. (defun points-to-rect (point1 point2 dest-rect)
  214.   (#_Pt2Rect (make-point point1 nil) (make-point point2 nil) dest-rect)
  215.   dest-rect)
  216.  
  217. (defun point-to-angle (rect h &optional v)
  218.   (%stack-block ((ip 4))
  219.     (#_PtToAngle rect (make-point h v) ip)
  220.     (%get-word ip)))
  221.  
  222. (defun equal-rect (rect1 rect2)
  223.   (#_EqualRect rect1 rect2))
  224.  
  225. (defun empty-rect-p (left &optional top right bot)
  226.   (with-rectangle-arg (r left top right bot)
  227.     (#_EmptyRect r)))
  228.  
  229. (defmethod frame-rect ((view simple-view) left &optional top right bot)
  230.  (with-focused-view view
  231.    (with-rectangle-arg (r left top right bot) (#_FrameRect r))))
  232.  
  233. (defmethod paint-rect ((view simple-view) left &optional top right bot)
  234.   (with-focused-view view
  235.     (with-rectangle-arg (r left top right bot) (#_PaintRect r))))
  236.  
  237. (defmethod erase-rect ((view simple-view) left &optional top right bot)
  238.   (with-focused-view view
  239.     (with-rectangle-arg (r left top right bot) (#_EraseRect r))))
  240.  
  241. (defmethod invert-rect ((view simple-view) left &optional top right bot)
  242.   (with-focused-view view
  243.     (with-rectangle-arg (r left top right bot) (#_InvertRect r))))
  244.  
  245. (defmethod fill-rect ((view simple-view) pattern left &optional top right bot)
  246.   (with-focused-view view
  247.     (with-rectangle-arg (r left top right bot)
  248.        (#_FillRect r pattern))))
  249.  
  250. (defmethod frame-oval ((view simple-view) left &optional top right bot)
  251.  (with-focused-view view
  252.    (with-rectangle-arg (r left top right bot) (#_FrameOval r))))
  253.  
  254. (defmethod paint-oval ((view simple-view) left &optional top right bot)
  255.   (with-focused-view view
  256.     (with-rectangle-arg (r left top right bot) (#_PaintOval r))))
  257.  
  258. (defmethod erase-oval ((view simple-view) left &optional top right bot)
  259.   (with-focused-view view
  260.     (with-rectangle-arg (r left top right bot) (#_EraseOval r))))
  261.  
  262. (defmethod invert-oval ((view simple-view) left &optional top right bot)
  263.   (with-focused-view view
  264.     (with-rectangle-arg (r left top right bot) (#_InvertOval r))))
  265.  
  266. (defmethod fill-oval ((view simple-view) pattern left &optional top right bot)
  267.   (with-focused-view view
  268.     (with-rectangle-arg (r left top right bot)
  269.        (#_FillOval r pattern))))
  270.  
  271. (defmethod frame-round-rect ((view simple-view) oval-width oval-height 
  272.                              left &optional top right bot)
  273.  (with-focused-view view
  274.    (with-rectangle-arg (r left top right bot)
  275.       (#_FrameRoundRect r oval-width oval-height))))
  276.  
  277. (defmethod paint-round-rect ((view simple-view) oval-width oval-height 
  278.                              left &optional top right bot)
  279.  (with-focused-view view
  280.    (with-rectangle-arg (r left top right bot)
  281.       (#_PaintRoundRect r oval-width oval-height))))
  282.  
  283. (defmethod erase-round-rect ((view simple-view) oval-width oval-height 
  284.                              left &optional top right bot)
  285.  (with-focused-view view
  286.    (with-rectangle-arg (r left top right bot)
  287.       (#_EraseRoundRect r oval-width oval-height))))
  288.  
  289. (defmethod invert-round-rect ((view simple-view) oval-width oval-height 
  290.                               left &optional top right bot)
  291.  (with-focused-view view
  292.    (with-rectangle-arg (r left top right bot)
  293.       (#_InvertRoundRect r oval-width oval-height))))
  294.  
  295. (defmethod fill-round-rect ((view simple-view) pattern oval-width oval-height 
  296.                             left &optional top right bot)
  297.   (with-focused-view view
  298.     (with-rectangle-arg (r left top right bot)
  299.        (#_FillRoundRect r oval-width oval-height pattern))))
  300.  
  301. (defmethod frame-arc ((view simple-view) start-angle arc-angle 
  302.                       left &optional top right bot)
  303.  (with-focused-view view
  304.    (with-rectangle-arg (r left top right bot)
  305.       (#_FrameArc r start-angle arc-angle))))
  306.  
  307. (defmethod paint-arc ((view simple-view) start-angle arc-angle 
  308.                       left &optional top right bot)
  309.  (with-focused-view view
  310.    (with-rectangle-arg (r left top right bot)
  311.       (#_PaintArc r start-angle arc-angle))))
  312.  
  313. (defmethod erase-arc ((view simple-view) start-angle arc-angle 
  314.                       left &optional top right bot)
  315.  (with-focused-view view
  316.    (with-rectangle-arg (r left top right bot)
  317.       (#_EraseArc r start-angle arc-angle))))
  318.  
  319. (defmethod invert-arc ((view simple-view) start-angle arc-angle 
  320.                        left &optional top right bot)
  321.  (with-focused-view view
  322.    (with-rectangle-arg (r left top right bot)
  323.       (#_InvertArc r start-angle arc-angle))))
  324.  
  325. (defmethod fill-arc ((view simple-view) pattern start-angle arc-angle
  326.                      left &optional top right bot)
  327.   (with-focused-view view
  328.     (with-rectangle-arg (r left top right bot)
  329.        (#_FillArc r start-angle arc-angle pattern))))
  330.  
  331. ;;;Regions
  332.  
  333. (defun new-region ()
  334.   (#_NewRgn))
  335.  
  336. (defun dispose-region (region)
  337.   (#_DisposeRgn region))
  338.  
  339. (defun copy-region (region &optional (dest-region (new-region)))
  340.   (#_CopyRgn region dest-region)
  341.   dest-region)
  342.  
  343. (defun set-empty-region (region)
  344.   (#_SetEmptyRgn region)
  345.   region)
  346.  
  347. (defun set-rect-region (region left &optional top right bot)
  348.   (with-rectangle-arg (r left top right bot)
  349.    (#_RectRgn region r))
  350.   region)
  351.  
  352. (defmethod open-region ((view simple-view))
  353.   (let ((wptr (wptr view)))
  354.     (unless (%null-ptr-p (pref wptr windowRecord.rgnSave))
  355.       (error "Region already open for window: ~a" view))
  356.     (with-port wptr (#_OpenRgn))))
  357.  
  358. (defmethod close-region ((view simple-view) &optional (dest-region (new-region) dp))
  359.   (let ((wptr (wptr view)))
  360.     (if (%null-ptr-p (pref wptr windowRecord.rgnSave))
  361.       (progn 
  362.         (if (not dp) (dispose-region dest-region))
  363.         (error "Region is not open for window: ~a" view)))
  364.     (with-port wptr
  365.       (#_CloseRgn dest-region)))
  366.   dest-region)
  367.  
  368. (defun offset-region (region h &optional v)
  369.   (#_OffsetRgn :ptr region :long (make-point h v))
  370.   region)
  371.  
  372. (defun inset-region (region h &optional v)
  373.   (#_InsetRgn :ptr region :long (make-point h v))
  374.   region)
  375.  
  376. (defun intersect-region (region1 region2 &optional (dest-region (new-region)))
  377.   (#_SectRgn region1 region2 dest-region)
  378.   dest-region)
  379.  
  380. (defun union-region (region1 region2 &optional (dest-region (new-region)))
  381.   (#_UnionRgn region1 region2 dest-region)
  382.   dest-region)
  383.  
  384. (defun difference-region (region1 region2 &optional (dest-region (new-region)))
  385.   (#_DiffRgn region1 region2 dest-region)
  386.   dest-region)
  387.  
  388. (defun xor-region (region1 region2 &optional (dest-region (new-region)))
  389.   (#_XorRgn region1 region2 dest-region)
  390.   dest-region)
  391.  
  392. (defun point-in-region-p (region h &optional v)
  393.   (#_PtInRgn (make-point h v) region))
  394.  
  395. (defun rect-in-region-p (region left &optional top right bot)
  396.  (with-rectangle-arg (r left top right bot)
  397.    (#_RectInRgn r region)))
  398.  
  399. (defun equal-region-p (region1 region2)
  400.   (#_EqualRgn region1 region2))
  401.  
  402. (defun empty-region-p (region)
  403.   (#_EmptyRgn region))
  404.  
  405. (defmethod frame-region ((view simple-view) region)
  406.   (with-focused-view view (#_FrameRgn region)))
  407.  
  408. (defmethod paint-region ((view simple-view) region)
  409.   (with-focused-view view (#_PaintRgn region)))
  410.  
  411. (defmethod erase-region ((view simple-view) region)
  412.   (with-focused-view view (#_EraseRgn region)))
  413.  
  414. (defmethod invert-region ((view simple-view) region)
  415.   (with-focused-view view (#_InvertRgn region)))
  416.  
  417. (defmethod fill-region ((view simple-view) pattern region)
  418.   (with-focused-view view 
  419.     (#_FillRgn region pattern)))
  420.  
  421. ;;;Pictures
  422.  
  423. (defmethod start-picture ((view simple-view) &optional left top right bottom)
  424.   (with-macptrs (portrect)
  425.     (let ((wptr (wptr view)))
  426.       (unless (%null-ptr-p (pref wptr windowRecord.picsave))
  427.         (error "A picture may not be started for window: ~a.
  428.            since one is already started" view))
  429.       (unless left (setq left (%setf-macptr portrect (pref wptr windowRecord.portrect)))))
  430.     (with-rectangle-arg (r left top right bottom)
  431.       (with-focused-view view
  432.         (#_cliprect r)
  433.         (setf (view-get view 'my-hPic) (#_OpenPicture r))))
  434.     nil))
  435.  
  436. (defmethod get-picture ((view simple-view))
  437.   (let ((my-hPic (view-get view 'my-hPic))
  438.         (wptr (wptr view)))
  439.     (if (and my-hPic (not (%null-ptr-p (pref wptr windowRecord.picSave))))
  440.       (prog1
  441.         my-hPic
  442.         (with-port wptr (#_ClosePicture))
  443.         (setf (view-get view 'my-hPic) nil))
  444.       (error "Picture for window: ~a is not started" view))))
  445.  
  446. (defmethod draw-picture ((view simple-view) picture &optional left top right bottom)
  447.  (cond ((not left)
  448.         (setq left (href picture picture.picFrame.topleft)
  449.               top (href picture picture.picFrame.bottomright)))
  450.        ((pointerp left)
  451.         ())  ;everythings fine
  452.        ((and (not right)
  453.              (not top))
  454.         (setq top
  455.               (add-points left
  456.                           (subtract-points
  457.                            (href picture picture.picframe.bottomright)
  458.                            (href picture picture.picframe.topleft))))))
  459.  (with-rectangle-arg (r left top right bottom)
  460.    (with-focused-view view
  461.      (#_DrawPicture picture r)))
  462.  picture)
  463.  
  464. (defun kill-picture (picture)
  465.   (#_KillPicture picture))
  466.  
  467. (defmethod start-polygon ((view simple-view))
  468.   (let ((wptr (wptr view)))
  469.     (unless (%null-ptr-p (pref wptr windowRecord.polysave))
  470.       (error "A new polygon may not be started for window: ~a.
  471.            since one is already started" view))
  472.     (with-port wptr (setf (view-get view 'my-poly) (#_OpenPoly))))
  473.   nil)
  474.  
  475. (defmethod get-polygon ((view simple-view))
  476.   (let ((my-poly (view-get view 'my-poly))
  477.         (wptr (wptr view)))
  478.     (if (and my-poly (not (%null-ptr-p (pref wptr windowRecord.polysave))))
  479.       (prog1
  480.         my-poly
  481.         (with-port wptr (#_ClosePoly))
  482.         (setf (view-get view 'my-poly) nil))
  483.       (error "Polygon for window: ~a has not been started" view))))
  484.  
  485. (defun kill-polygon (polygon)
  486.   (#_KillPoly polygon))
  487.  
  488. (defun offset-polygon (polygon h &optional v)
  489.   (#_OffsetPoly :ptr polygon :long (make-point h v))
  490.   polygon)
  491.  
  492. (defmethod frame-polygon ((view simple-view) polygon)
  493.   (with-focused-view view (#_FramePoly polygon)))
  494.  
  495. (defmethod paint-polygon ((view simple-view) polygon)
  496.   (with-focused-view view (#_PaintPoly polygon)))
  497.  
  498. (defmethod erase-polygon ((view simple-view) polygon)
  499.   (with-focused-view view (#_ErasePoly polygon)))
  500.  
  501. (defmethod invert-polygon ((view simple-view) polygon)
  502.   (with-focused-view view (#_InvertPoly polygon)))
  503.  
  504. (defmethod fill-polygon ((view simple-view) pattern polygon)
  505.  (with-focused-view view
  506.    (#_FillPoly polygon pattern)))
  507.  
  508.  
  509.  
  510. (defmethod local-to-global ((view simple-view) h &optional v)
  511.   (with-focused-view view
  512.     (rlet ((p :point))
  513.       (%put-long p (make-point h v))
  514.       (#_LocalToGlobal p)
  515.       (%get-long p))))
  516.  
  517. (defmethod global-to-local ((view simple-view) h &optional v)
  518.   (with-focused-view view
  519.     (rlet ((p :point))
  520.       (%put-long p (make-point h v))
  521.       (#_GlobalToLocal p)
  522.       (%get-long p))))
  523.  
  524. (defmethod get-pixel ((view simple-view) h &optional v)
  525.   (with-focused-view view
  526.     (setq h (make-point h v))
  527.     (if (#_PtInRgn h (pref (wptr view) windowRecord.visrgn))
  528.       (#_GetPixel :long h :boolean))))
  529.  
  530. (defun scale-point (source-rect dest-rect h &optional v)
  531.   (rlet ((pt :point))
  532.     (%put-long pt (make-point h v))
  533.     (#_ScalePt pt source-rect dest-rect)
  534.     (%get-long pt)))
  535.  
  536. (defun map-point (source-rect dest-rect h &optional v)
  537.   (rlet ((pt :point))
  538.     (%put-long pt (make-point h v))
  539.     (#_MapPt pt source-rect dest-rect)
  540.     (%get-long pt)))
  541.  
  542. (defun map-rect (source-rect dest-rect rect)
  543.   (#_MapRect rect source-rect dest-rect)
  544.   rect)
  545.  
  546. (defun map-region (source-rect dest-rect region)
  547.   (#_MapRgn region source-rect dest-rect)
  548.   region)
  549.  
  550. (defun map-polygon (source-rect dest-rect polygon)
  551.   (#_MapPoly polygon source-rect dest-rect)
  552.   polygon)
  553.  
  554. (defun make-bitmap (left &optional top right bottom &aux rowbytes bm)
  555.   (with-rectangle-arg (r left top right bottom)
  556.     (setq rowbytes 
  557.           (logand
  558.            #xfffe 
  559.            (+ 2  (ash (- (pref r rect.right) (pref r rect.left) 1) -3))))
  560.     (setq bm 
  561.           (#_NewPtr :check-error
  562.                     (+ 14 (* rowbytes (- (pref r rect.bottom) (pref r rect.top))))))
  563.     (setf (pref bm bitmap.bounds) r)
  564.     (setf (pref bm bitmap.rowbytes) rowbytes)
  565.     (setf (pref bm bitmap.baseaddr) (%inc-ptr bm 14)))
  566.   bm)
  567.  
  568.  
  569. (defun copy-bits (source-bitmap dest-bitmap source-rect dest-rect
  570.                                 &optional (mode 0) mask-region)
  571.   (with-macptrs ((mask-region (if mask-region mask-region (%null-ptr))))
  572.     (with-pointers ((sb source-bitmap)
  573.                     (db dest-bitmap))
  574.       (#_CopyBits sb db source-rect dest-rect (mode-arg mode) mask-region))))
  575.  
  576. (defmethod scroll-rect ((view simple-view) rect dh &optional dv)
  577.   "ignores any clipping regions"
  578.   (with-focused-view view
  579.     (let* ((reg (#_newrgn)))
  580.       (#_ScrollRect :ptr rect
  581.                     :long (make-point dh dv)
  582.                     :ptr reg)
  583.       (#_invalrgn reg)
  584.       (#_disposergn reg))))
  585.  
  586. (provide 'quickdraw)
  587. (pushnew :quickdraw *features*)
  588.